Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue35/RTTI/PropertyIO.pas

Pascal/Delphi Source File | 1998-04-12 | 11.6 KB | 384 lines

unit PropertyIO;

interface

uses
  Classes, SysUtils;

type

  {$TYPEINFO ON}
  TSQLObject = class (TPersistent)
  private
    FPropertyList: TStringList;
    function GetPropList: TStringList;
    function GetSQLProperty (PropertyName: String): String;
  protected
    function TableName: String; virtual;
    function SQLInsert: String;
    function SQLUpdate: String;
    function SQLSelect: String;
    property PropertyList: TStringList read GetPropList;
  public
    destructor Destroy; override;
  end;
  {$TYPEINFO OFF}

  TPropertyImporter = class (TComponent)
  private
    FOnObjectImported: TNotifyEvent;
  public
    procedure ImportFile (FileName: String);
  published
    property OnObjectImported: TNotifyEvent read FOnObjectImported write FOnObjectImported;
  end;

  EPropertyImporter = class (Exception);

  TPropertyExporter = class (TComponent)
  private
    FPropertyList: TStringList;
    FFileName: String;
    OutputStream: TFileStream;
    procedure WriteLine (Text: String);
    procedure SetFileName (Value: String);
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure ExportObject (ThisObject: TObject);
  published
    property PropertyList: TStringList read FPropertyList;
    property FileName: String read FFileName write SetFileName;
  end;

procedure Register;

implementation

uses
  TypInfo;

// unit procedures

procedure SetProperty (ThisObject: TObject; PropertyName, Value: String);
var
  PropertyPtr: PPropInfo;
begin
  // Get reference to property info.
  PropertyPtr := GetPropInfo (ThisObject.ClassInfo, PropertyName);

  if PropertyPtr <> nil then begin
    // RTTI available, set the property value if not read-only
    if PropertyPtr^.SetProc <> nil then begin
      // Determine property type and set value accordingly.
      case PropertyPtr^.PropType^.Kind of
        tkString, tkLString, tkChar: SetStrProp (ThisObject, PropertyPtr, Value);
        tkEnumeration:               SetOrdProp (ThisObject, PropertyPtr, GetEnumValue (PropertyPtr^.PropType^, Value));
        tkInteger:                   SetOrdProp (ThisObject, PropertyPtr, StrToInt (Value));
        tkFloat:                     SetFloatProp (ThisObject, PropertyPtr, StrToFloat (Value));
        tkVariant:                   SetVariantProp (ThisObject, PropertyPtr, Value);
      else
        raise EConvertError.Create ('unknown property type');
      end;
    end;
  end;
end;

function GetProperty (ThisObject: TObject; PropertyName: String): String;
var
  PropertyPtr : PPropInfo;
begin
  // supply default result in case property access fails
  Result := '';
  // get reference to property info.
  PropertyPtr := GetPropInfo (ThisObject.ClassInfo, PropertyName);
  if PropertyPtr <> nil then begin
    // determine property type and return string accordingly.
    case PropertyPtr^.PropType^.Kind of
      tkString, tkLString:  Result := GetStrProp (ThisObject, PropertyPtr);
      tkEnumeration:        Result := GetEnumName (PropertyPtr^.PropType^, GetOrdProp (ThisObject, PropertyPtr));
      tkInteger:            Result := IntToStr (GetOrdProp (ThisObject, PropertyPtr));
      tkChar:               Result := Char (GetOrdProp (ThisObject, PropertyPtr));
      tkFloat:              Result := FloatToStr (GetFloatProp (ThisObject, PropertyPtr));
      tkVariant:            Result := GetVariantProp (ThisObject, PropertyPtr);
    end;
  end;
end;

procedure GetPropertyList (ThisObject: TObject; PropertyList: TStringList);
var
  ThisProperty: Integer;
  PropertyCount: Integer;
  PropList: PPropList;
begin
  // find out how many properties the object has
  PropertyCount := GetTypeData (ThisObject.ClassInfo)^.PropCount;
  // iterate through the properties collecting their names
  if PropertyCount > 0 then begin
    GetMem (PropList, PropertyCount * SizeOf (Pointer));
    try
      GetPropInfos (ThisObject.ClassInfo, PropList);
      for ThisProperty := 0 to PropertyCount - 1 do begin
        if IsStoredProp (ThisObject, GetPropInfo (ThisObject.ClassInfo, PropList^[ThisProperty]^.Name)) then begin
          PropertyList.Add (PropList^[ThisProperty]^.Name);
        end;
      end;
    finally
      FreeMem (PropList, PropertyCount * SizeOf (Pointer));
    end;
  end;
end;

function GetPropertyType (ThisObject: TObject; PropertyName: String): TTypeKind;
var
  PropertyPtr : PPropInfo;
begin
  // get reference to property info.
  PropertyPtr := GetPropInfo (ThisObject.ClassInfo, PropertyName);
  if PropertyPtr <> nil then begin
    // determine property type and return string accordingly.
    Result := PropertyPtr^.PropType^.Kind;
  end else begin
    Result := tkUnknown;
  end;
end;

// TPropertyExporter

constructor TPropertyExporter.Create (AOwner: TComponent);
begin
  inherited;
  FPropertyList := TStringList.Create;
  FFileName := 'Export.TXT';
end;

destructor TPropertyExporter.Destroy;
begin
  OutputStream.Free;
  FPropertyList.Free;
  inherited;
end;

procedure TPropertyExporter.SetFileName (Value: String);
begin
  OutputStream.Free;
  OutputStream := nil;
  FFileName := Value;
end;

procedure TPropertyExporter.WriteLine (Text: String);
const
  CRLF = #13 + #10;
begin
  Text := Text + CRLF;
  if OutputStream = nil then begin
    OutputStream := TFileStream.Create (FileName, fmCreate or fmShareExclusive);
  end;
  OutputStream.Write (Text[1], Length (Text));
end;

procedure TPropertyExporter.ExportObject (ThisObject: TObject);
var
  ThisProperty: Integer;
  PropertyValue: String;
begin
  // populate the property list with all properties for the object if it is empty
  if PropertyList.Count = 0 then begin
    GetPropertyList (ThisObject, PropertyList);
  end;
  // now output the object, including the BEGIN and END delimiters
  WriteLine ('BEGIN ' + ThisObject.ClassName);
  for ThisProperty := 0 to PropertyList.Count - 1 do begin
    PropertyValue := GetProperty (ThisObject, PropertyList[ThisProperty]);
    WriteLine (PropertyList[ThisProperty] + '=' + PropertyValue);
  end;
  WriteLine ('END');
  OutputStream.Free;
  OutputStream := nil;
end;

// TPropertyImporter

procedure TPropertyImporter.ImportFile (FileName: String);
var
  LineNumber: Integer;
  InputFile: TextFile;

  function ReadLine: String;
  begin
    repeat
      ReadLn (InputFile, Result);
      Result := Trim (Result);
      Inc (LineNumber);
    until Result <> '';
  end;

var
  Text: String;
  ThisClass: TPersistentClass;
  ThisObject: TPersistent;
  EndOfClass: Boolean;
  PropName: String;
  PropValue: String;
begin
  if not FileExists (FileName) then begin
    raise EPropertyImporter.CreateFmt ('Error reading %s: file does not exist', [FileName]);
  end;

  AssignFile (InputFile, FileName);
  try
    Reset (InputFile);

    while not EOF (InputFile) do begin
      // read a line from the input file - it should be of the form "BEGIN <ClassName>"
      Text := ReadLine;
      LineNumber := 0;
      if Pos ('BEGIN ', UpperCase (Text)) = 0 then begin
        raise EPropertyImporter.CreateFmt ('Error reading %s at line %d: BEGIN <ClassName> expected.', [FileName, LineNumber]);
      end;
      // decode the class name
      Text := Copy (Text, Pos (' ', Text) + 1, Length (Text));
      // create a class of the correct type
      ThisClass := GetClass (Text);
      if ThisClass = nil then begin
        raise EPropertyImporter.CreateFmt ('Error reading %s at line %d: class %s is not registered.', [FileName, LineNumber, Text]);
      end;
      ThisObject := ThisClass.Create;
      try
        // read in lines until we hit an "END"
        EndOfClass := False;
        repeat
          Text := ReadLine;
          if UpperCase (Text) = 'END' then begin
            EndOfClass := True;
          end else if Pos ('=', Text) = 0 then begin
            raise EPropertyImporter.CreateFmt ('Error reading %s at line %d: "Name=Value" syntax expected.', [FileName, LineNumber]);
          end else begin
            // split the line at the "=" sign into a property name and a value
            PropName := Copy (Text, 1, Pos ('=', Text) - 1);
            PropValue := Copy (Text, Pos ('=', Text) + 1, Length (Text));
            // set the property on the object
            SetProperty (ThisObject, PropName, PropValue);
          end;
        until EndOfClass;
        // if assigned, call the event to save the object
        if Assigned (OnObjectImported) then begin
          OnObjectImported (ThisObject);
        end;
      finally
        ThisObject.Free;
      end;
    end;

  finally
    CloseFile (InputFile);
  end;
end;

// TSQLObject

destructor TSQLObject.Destroy;
begin
  FPropertyList.Free;
  inherited;
end;

function TSQLObject.GetPropList: TStringList;
begin
  if FPropertyList = nil then begin
    FPropertyList := TStringList.Create;
    // obtain a list of all published properties in the class and ancestors
    GetPropertyList (Self, FPropertyList);
  end;
  Result := FPropertyList;
end;

function TSQLObject.TableName: String;
begin
  Result := Copy (ClassName, 2, Length (ClassName) - 1);
end;

function TSQLObject.GetSQLProperty (PropertyName: String): String;
begin
  case GetPropertyType (Self, PropertyName) of
    tkString,
    tkLString,
    tkChar:        Result := '"' + GetProperty (Self, PropertyName) + '"';
    tkEnumeration: Result := IntToStr (GetOrdProp (Self, GetPropInfo (Self.ClassInfo, PropertyName)));
    tkInteger,
    tkFloat:       Result := GetProperty (Self, PropertyName);
  else
    Result := '';
  end;
end;

function TSQLObject.SQLInsert: String;
var
  Fields: String;
  Values: String;
  ThisValue: String;
  ThisProp: Integer;
begin
  Fields := '';
  Values := '';
  for ThisProp := 0 to PropertyList.Count - 1 do begin
    ThisValue := GetSQLProperty (PropertyList[ThisProp]);
    if ThisValue <> '' then begin
      Fields := Fields + ',' + PropertyList[ThisProp];
      Values := Values + ',' + ThisValue;
    end;
  end;
  // strip leading comma not required
  Fields := Copy (Fields, 2, Length (Fields) - 1);
  Values := Copy (Values, 2, Length (Values) - 1);
  // build up the SQL text
  Result := Format ('INSERT INTO %s (%s) VALUES (%s)', [TableName, Fields, Values]);
end;

function TSQLObject.SQLUpdate: String;
var
  Fields: String;
  ThisValue: String;
  ThisProp: Integer;
begin
  Fields := '';
  for ThisProp := 0 to PropertyList.Count - 1 do begin
    ThisValue := GetSQLProperty (PropertyList[ThisProp]);
    if ThisValue <> '' then begin
      Fields := Fields + ',' + PropertyList[ThisProp] + '=' + ThisValue;
    end;
  end;
  // strip leading comma not required
  Fields := Copy (Fields, 2, Length (Fields) - 1);
  // build up the SQL text
  Result := Format ('UPDATE %s SET %s WHERE', [TableName, Fields]);
  // you will need to append a way of identifying each class uniquely
end;

function TSQLObject.SQLSelect: String;
var
  ThisProp: Integer;
  Fields: String;
begin
  Fields := '';
  for ThisProp := 0 to PropertyList.Count - 1 do begin
    Fields := Fields + ',' + PropertyList[ThisProp];
  end;
  // strip leading comma not required
  Fields := Copy (Fields, 2, Length (Fields) - 1);
  // build up the SQL text
  Result := Format ('SELECT %s FROM %s', [Fields, TableName]);
  // after fetching the data from the database using the above command,
  // you could cycle through the properties, fetching values from the cursor
  // and using SetProperty to update the object
end;

// unit procedures

procedure Register;
begin
  RegisterComponents ('Delphi Magazine', [TPropertyImporter, TPropertyExporter]);
end;

end.